home *** CD-ROM | disk | FTP | other *** search
/ Disc to the Future 2 / Disc to the Future Part II Programmer's Reference (Wayzata Technology)(6013)(1992).bin / MAC / MPW_TOOL / TOOLS / TOOLS_WI / PERL / UNTESTED / X2P / S2P.SH (.txt) < prev    next >
Microsoft Windows Help File Content  |  1992-01-05  |  14KB  |  619 lines
  1. : This forces SH files to create target in same directory as SH file.
  2. : This is so that make depend always knows where to find SH derivatives.
  3. case "$0" in
  4. */*) cd `expr X$0 : 'X\(.*\)/'` ;;
  5. case $CONFIG in
  6.     if test ! -f config.sh; then
  7.     ln ../config.sh . || \
  8.     ln -s ../config.sh . || \
  9.     ln ../../config.sh . || \
  10.     ln ../../../config.sh . || \
  11.     (echo "Can't find config.sh."; exit 1)
  12.     fi 2>/dev/null
  13.     . ./config.sh
  14.     ;;
  15. echo "Extracting s2p (with variable substitutions)"
  16. : This section of the file will have variable substitutions done on it.
  17. : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
  18. : Protect any dollar signs and backticks that you do not want interpreted
  19. : by putting a backslash in front.  You may delete these comments.
  20. $spitshell >s2p <<!GROK!THIS!
  21. #!$bin/perl
  22. \$bin = '$bin';
  23. !GROK!THIS!
  24. : In the following dollars and backticks do not need the extra backslash.
  25. $spitshell >>s2p <<'!NO!SUBS!'
  26. # $RCSfile: s2p.SH,v $$Revision: 4.0.1.1 $$Date: 91/06/07 12:19:18 $
  27. # $Log:    s2p.SH,v $
  28. # Revision 4.0.1.1  91/06/07  12:19:18  lwall
  29. # patch4: s2p now handles embedded newlines better and optimizes common idioms
  30. # Revision 4.0  91/03/20  01:57:59  lwall
  31. # 4.0 baseline.
  32. $indent = 4;
  33. $shiftwidth = 4;
  34. $l = '{'; $r = '}';
  35. while ($ARGV[0] =~ /^-/) {
  36.     $_ = shift;
  37.   last if /^--/;
  38.     if (/^-D/) {
  39.     $debug++;
  40.     open(BODY,'>-');
  41.     next;
  42.     }
  43.     if (/^-n/) {
  44.     $assumen++;
  45.     next;
  46.     }
  47.     if (/^-p/) {
  48.     $assumep++;
  49.     next;
  50.     }
  51.     die "I don't recognize this switch: $_\n";
  52. unless ($debug) {
  53.     open(BODY,">/tmp/sperl$$") ||
  54.       &Die("Can't open temp file: $!\n");
  55. if (!$assumen && !$assumep) {
  56.     print BODY &q(<<'EOT');
  57. :    while ($ARGV[0] =~ /^-/) {
  58. :        $_ = shift;
  59. :      last if /^--/;
  60. :        if (/^-n/) {
  61. :        $nflag++;
  62. :        next;
  63. :        }
  64. :        die "I don't recognize this switch: $_\\n";
  65. print BODY &q(<<'EOT');
  66. :    #ifdef PRINTIT
  67. :    #ifdef ASSUMEP
  68. :    $printit++;
  69. :    #else
  70. :    $printit++ unless $nflag;
  71. :    #endif
  72. :    #endif
  73. :    <><>
  74. :    $\ = "\n";        # automatically add newline on print
  75. :    <><>
  76. :    #ifdef TOPLABEL
  77. :    LINE:
  78. :    while (chop($_ = <>)) {
  79. :    #else
  80. :    LINE:
  81. :    while (<>) {
  82. :        chop;
  83. :    #endif
  84. LINE:
  85. while (<>) {
  86.     # Wipe out surrounding whitespace.
  87.     s/[ \t]*(.*)\n$/$1/;
  88.     # Perhaps it's a label/comment.
  89.     if (/^:/) {
  90.     s/^:[ \t]*//;
  91.     $label = &make_label($_);
  92.     if ($. == 1) {
  93.         $toplabel = $label;
  94.         if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) {
  95.         $_ = <>;
  96.         redo LINE; # Never referenced, so delete it if not a comment.
  97.         }
  98.     $_ = "$label:";
  99.     if ($lastlinewaslabel++) {
  100.         $indent += 4;
  101.         print BODY &tab, ";\n";
  102.         $indent -= 4;
  103.     if ($indent >= 2) {
  104.         $indent -= 2;
  105.         $indmod = 2;
  106.     next;
  107.     } else {
  108.     $lastlinewaslabel = '';
  109.     }
  110.     # Look for one or two address clauses
  111.     $addr1 = '';
  112.     $addr2 = '';
  113.     if (s/^([0-9]+)//) {
  114.     $addr1 = "$1";
  115.     $addr1 = "\$. == $addr1" unless /^,/;
  116.     }
  117.     elsif (s/^\$//) {
  118.     $addr1 = 'eof()';
  119.     }
  120.     elsif (s|^/||) {
  121.     $addr1 = &fetchpat('/');
  122.     }
  123.     if (s/^,//) {
  124.     if (s/^([0-9]+)//) {
  125.         $addr2 = "$1";
  126.     } elsif (s/^\$//) {
  127.         $addr2 = "eof()";
  128.     } elsif (s|^/||) {
  129.         $addr2 = &fetchpat('/');
  130.     } else {
  131.         &Die("Invalid second address at line $.\n");
  132.     $addr1 .= " .. $addr2";
  133.     }
  134.     # Now we check for metacommands {, }, and ! and worry
  135.     # about indentation.
  136.     s/^[ \t]+//;
  137.     # a { to keep vi happy
  138.     if ($_ eq '}') {
  139.     $indent -= 4;
  140.     next;
  141.     }
  142.     if (s/^!//) {
  143.     $if = 'unless';
  144.     $else = "$r else $l\n";
  145.     } else {
  146.     $if = 'if';
  147.     $else = '';
  148.     }
  149.     if (s/^{//) {    # a } to keep vi happy
  150.     $indmod = 4;
  151.     $redo = $_;
  152.     $_ = '';
  153.     $rmaybe = '';
  154.     } else {
  155.     $rmaybe = "\n$r";
  156.     if ($addr2 || $addr1) {
  157.         $space = ' ' x $shiftwidth;
  158.     } else {
  159.         $space = '';
  160.     $_ = &transmogrify();
  161.     }
  162.     # See if we can optimize to modifier form.
  163.     if ($addr1) {
  164.     if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
  165.       $_ !~ / if / && $_ !~ / unless /) {
  166.         s/;$/ $if $addr1;/;
  167.         $_ = substr($_,$shiftwidth,1000);
  168.     } else {
  169.         $_ = "$if ($addr1) $l\n$change$_$rmaybe";
  170.     $change = '';
  171.     next LINE;
  172.     }
  173. } continue {
  174.     @lines = split(/\n/,$_);
  175.     for (@lines) {
  176.     unless (s/^ *<<--//) {
  177.         print BODY &tab;
  178.     print BODY $_, "\n";
  179.     }
  180.     $indent += $indmod;
  181.     $indmod = 0;
  182.     if ($redo) {
  183.     $_ = $redo;
  184.     $redo = '';
  185.     redo LINE;
  186.     }
  187. if ($lastlinewaslabel++) {
  188.     $indent += 4;
  189.     print BODY &tab, ";\n";
  190.     $indent -= 4;
  191. if ($appendseen || $tseen || !$assumen) {
  192.     $printit++ if $dseen || (!$assumen && !$assumep);
  193.     print BODY &q(<<'EOT');
  194. :    #ifdef SAWNEXT
  195. :    continue {
  196. :    #endif
  197. :    #ifdef PRINTIT
  198. :    #ifdef DSEEN
  199. :    #ifdef ASSUMEP
  200. :        print if $printit++;
  201. :    #else
  202. :        if ($printit)
  203. :        { print; }
  204. :        else
  205. :        { $printit++ unless $nflag; }
  206. :    #endif
  207. :    #else
  208. :        print if $printit;
  209. :    #endif
  210. :    #else
  211. :        print;
  212. :    #endif
  213. :    #ifdef TSEEN
  214. :        $tflag = 0;
  215. :    #endif
  216. :    #ifdef APPENDSEEN
  217. :        if ($atext) { chop $atext; print $atext; $atext = ''; }
  218. :    #endif
  219. print BODY &q(<<'EOT');
  220. close BODY;
  221. unless ($debug) {
  222.     open(HEAD,">/tmp/sperl2$$.c")
  223.       || &Die("Can't open temp file 2: $!\n");
  224.     print HEAD "#define PRINTIT\n"    if $printit;
  225.     print HEAD "#define APPENDSEEN\n"    if $appendseen;
  226.     print HEAD "#define TSEEN\n"    if $tseen;
  227.     print HEAD "#define DSEEN\n"    if $dseen;
  228.     print HEAD "#define ASSUMEN\n"    if $assumen;
  229.     print HEAD "#define ASSUMEP\n"    if $assumep;
  230.     print HEAD "#define TOPLABEL\n"    if $toplabel;
  231.     print HEAD "#define SAWNEXT\n"    if $sawnext;
  232.     if ($opens) {print HEAD "$opens\n";}
  233.     open(BODY,"/tmp/sperl$$")
  234.       || &Die("Can't reopen temp file: $!\n");
  235.     while (<BODY>) {
  236.     print HEAD $_;
  237.     }
  238.     close HEAD;
  239.     print &q(<<"EOT");
  240. :    #!$bin/perl
  241. :    eval 'exec $bin/perl -S \$0 \${1+"\$@"}'
  242. :        if \$running_under_some_shell;
  243.     open(BODY,"cc -E /tmp/sperl2$$.c |") ||
  244.     &Die("Can't reopen temp file: $!\n");
  245.     while (<BODY>) {
  246.     /^# [0-9]/ && next;
  247.     /^[ \t]*$/ && next;
  248.     s/^<><>//;
  249.     print;
  250.     }
  251. &Cleanup;
  252. exit;
  253. sub Cleanup {
  254.     chdir "/tmp";
  255.     unlink "sperl$$", "sperl2$$", "sperl2$$.c";
  256. sub Die {
  257.     &Cleanup;
  258.     die $_[0];
  259. sub tab {
  260.     "\t" x ($indent / 8) . ' ' x ($indent % 8);
  261. sub make_filehandle {
  262.     local($_) = $_[0];
  263.     local($fname) = $_;
  264.     if (!$seen{$fname}) {
  265.     $_ = "FH_" . $_ if /^\d/;
  266.     s/[^a-zA-Z0-9]/_/g;
  267.     s/^_*//;
  268.     $_ = "\U$_";
  269.     if ($fhseen{$_}) {
  270.         for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
  271.         $_ .= $tmp;
  272.     $fhseen{$_} = 1;
  273.     $opens .= &q(<<"EOT");
  274. :    open($_, '>$fname') || die "Can't create $fname: \$!";
  275.     $seen{$fname} = $_;
  276.     }
  277.     $seen{$fname};
  278. sub make_label {
  279.     local($label) = @_;
  280.     $label =~ s/[^a-zA-Z0-9]/_/g;
  281.     if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
  282.     $label = substr($label,0,8);
  283.     # Could be a reserved word, so capitalize it.
  284.     substr($label,0,1) =~ y/a-z/A-Z/
  285.       if $label =~ /^[a-z]/;
  286.     $label;
  287. sub transmogrify {
  288.     {    # case
  289.     if (/^d/) {
  290.         $dseen++;
  291.         chop($_ = &q(<<'EOT'));
  292. :    <<--#ifdef PRINTIT
  293. :    $printit = 0;
  294. :    <<--#endif
  295. :    next LINE;
  296.         $sawnext++;
  297.         next;
  298.     if (/^n/) {
  299.         chop($_ = &q(<<'EOT'));
  300. :    <<--#ifdef PRINTIT
  301. :    <<--#ifdef DSEEN
  302. :    <<--#ifdef ASSUMEP
  303. :    print if $printit++;
  304. :    <<--#else
  305. :    if ($printit)
  306. :        { print; }
  307. :    else
  308. :        { $printit++ unless $nflag; }
  309. :    <<--#endif
  310. :    <<--#else
  311. :    print if $printit;
  312. :    <<--#endif
  313. :    <<--#else
  314. :    print;
  315. :    <<--#endif
  316. :    <<--#ifdef APPENDSEEN
  317. :    if ($atext) {chop $atext; print $atext; $atext = '';}
  318. :    <<--#endif
  319. :    $_ = <>;
  320. :    chop;
  321. :    <<--#ifdef TSEEN
  322. :    $tflag = 0;
  323. :    <<--#endif
  324.         next;
  325.     if (/^a/) {
  326.         $appendseen++;
  327.         $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
  328.         $lastline = 0;
  329.         while (<>) {
  330.         s/^[ \t]*//;
  331.         s/^[\\]//;
  332.         unless (s|\\$||) { $lastline = 1;}
  333.         s/^([ \t]*\n)/<><>$1/;
  334.         $command .= $_;
  335.         $command .= '<<--';
  336.         last if $lastline;
  337.         }
  338.         $_ = $command . "End_Of_Text";
  339.         last;
  340.     if (/^[ic]/) {
  341.         if (/^c/) { $change = 1; }
  342.         $addr1 = 1 if $addr1 eq '';
  343.         $addr1 = '$iter = (' . $addr1 . ')';
  344.         $command = $space .
  345.           "    if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
  346.         $lastline = 0;
  347.         while (<>) {
  348.         s/^[ \t]*//;
  349.         s/^[\\]//;
  350.         unless (s/\\$//) { $lastline = 1;}
  351.         s/'/\\'/g;
  352.         s/^([ \t]*\n)/<><>$1/;
  353.         $command .= $_;
  354.         $command .= '<<--';
  355.         last if $lastline;
  356.         }
  357.         $_ = $command . "End_Of_Text";
  358.         if ($change) {
  359.         $dseen++;
  360.         $change = "$_\n";
  361.         chop($_ = &q(<<"EOT"));
  362. :    <<--#ifdef PRINTIT
  363. :    $space\$printit = 0;
  364. :    <<--#endif
  365. :    ${space}next LINE;
  366.         $sawnext++;
  367.         }
  368.         last;
  369.     if (/^s/) {
  370.         $delim = substr($_,1,1);
  371.         $len = length($_);
  372.         $repl = $end = 0;
  373.         $inbracket = 0;
  374.         for ($i = 2; $i < $len; $i++) {
  375.         $c = substr($_,$i,1);
  376.         if ($c eq $delim) {
  377.             if ($inbracket) {
  378.             substr($_, $i, 0) = '\\';
  379.             $i++;
  380.             $len++;
  381.             }
  382.             else {
  383.             if ($repl) {
  384.                 $end = $i;
  385.                 last;
  386.             } else {
  387.                 $repl = $i;
  388.             }
  389.         elsif ($c eq '\\') {
  390.             $i++;
  391.             if ($i >= $len) {
  392.             $_ .= 'n';
  393.             $_ .= <>;
  394.             $len = length($_);
  395.             $_ = substr($_,0,--$len);
  396.             }
  397.             elsif (substr($_,$i,1) =~ /^[n]$/) {
  398.             }
  399.             elsif (!$repl &&
  400.               substr($_,$i,1) =~ /^[(){}\w]$/) {
  401.             $i--;
  402.             $len--;
  403.             substr($_, $i, 1) = '';
  404.             }
  405.             elsif (!$repl &&
  406.               substr($_,$i,1) =~ /^[<>]$/) {
  407.             substr($_,$i,1) = 'b';
  408.             }
  409.         elsif ($c eq '[' && !$repl) {
  410.             $i++ if substr($_,$i,1) eq '^';
  411.             $i++ if substr($_,$i,1) eq ']';
  412.             $inbracket = 1;
  413.         elsif ($c eq ']') {
  414.             $inbracket = 0;
  415.         elsif ($c eq "\t") {
  416.             substr($_, $i, 1) = '\\t';
  417.             $i++;
  418.             $len++;
  419.         elsif (!$repl && index("()+",$c) >= 0) {
  420.             substr($_, $i, 0) = '\\';
  421.             $i++;
  422.             $len++;
  423.         }
  424.         &Die("Malformed substitution at line $.\n")
  425.           unless $end;
  426.         $pat = substr($_, 0, $repl + 1);
  427.         $repl = substr($_, $repl+1, $end-$repl-1);
  428.         $end = substr($_, $end + 1, 1000);
  429.         &simplify($pat);
  430.         $dol = '$';
  431.         $repl =~ s/\$/\\$/;
  432.         $repl =~ s'&'$&'g;
  433.         $repl =~ s/[\\]([0-9])/$dol$1/g;
  434.         $subst = "$pat$repl$delim";
  435.         $cmd = '';
  436.         while ($end) {
  437.         if ($end =~ s/^g//) {
  438.             $subst .= 'g';
  439.             next;
  440.         if ($end =~ s/^p//) {
  441.             $cmd .= ' && (print)';
  442.             next;
  443.         if ($end =~ s/^w[ \t]*//) {
  444.             $fh = &make_filehandle($end);
  445.             $cmd .= " && (print $fh \$_)";
  446.             $end = '';
  447.             next;
  448.         &Die("Unrecognized substitution command".
  449.           "($end) at line $.\n");
  450.         }
  451.         chop ($_ = &q(<<"EOT"));
  452. :    <<--#ifdef TSEEN
  453. :    $subst && \$tflag++$cmd;
  454. :    <<--#else
  455. :    $subst$cmd;
  456. :    <<--#endif
  457.         next;
  458.     if (/^p/) {
  459.         $_ = 'print;';
  460.         next;
  461.     if (/^w/) {
  462.         s/^w[ \t]*//;
  463.         $fh = &make_filehandle($_);
  464.         $_ = "print $fh \$_;";
  465.         next;
  466.     if (/^r/) {
  467.         $appendseen++;
  468.         s/^r[ \t]*//;
  469.         $file = $_;
  470.         $_ = "\$atext .= `cat $file 2>/dev/null`;";
  471.         next;
  472.     if (/^P/) {
  473.         $_ = 'print $1 if /^(.*)/;';
  474.         next;
  475.     if (/^D/) {
  476.         chop($_ = &q(<<'EOT'));
  477. :    s/^.*\n?//;
  478. :    redo LINE if $_;
  479. :    next LINE;
  480.         $sawnext++;
  481.         next;
  482.     if (/^N/) {
  483.         chop($_ = &q(<<'EOT'));
  484. :    $_ .= "\n";
  485. :    $len1 = length;
  486. :    $_ .= <>;
  487. :    chop if $len1 < length;
  488. :    <<--#ifdef TSEEN
  489. :    $tflag = 0;
  490. :    <<--#endif
  491.         next;
  492.     if (/^h/) {
  493.         $_ = '$hold = $_;';
  494.         next;
  495.     if (/^H/) {
  496.         $_ = '$hold .= "\n"; $hold .= $_;';
  497.         next;
  498.     if (/^g/) {
  499.         $_ = '$_ = $hold;';
  500.         next;
  501.     if (/^G/) {
  502.         $_ = '$_ .= "\n"; $_ .= $hold;';
  503.         next;
  504.     if (/^x/) {
  505.         $_ = '($_, $hold) = ($hold, $_);';
  506.         next;
  507.     if (/^b$/) {
  508.         $_ = 'next LINE;';
  509.         $sawnext++;
  510.         next;
  511.     if (/^b/) {
  512.         s/^b[ \t]*//;
  513.         $lab = &make_label($_);
  514.         if ($lab eq $toplabel) {
  515.         $_ = 'redo LINE;';
  516.         } else {
  517.         $_ = "goto $lab;";
  518.         }
  519.         next;
  520.     if (/^t$/) {
  521.         $_ = 'next LINE if $tflag;';
  522.         $sawnext++;
  523.         $tseen++;
  524.         next;
  525.     if (/^t/) {
  526.         s/^t[ \t]*//;
  527.         $lab = &make_label($_);
  528.         $_ = q/if ($tflag) {$tflag = 0; /;
  529.         if ($lab eq $toplabel) {
  530.         $_ .= 'redo LINE;}';
  531.         } else {
  532.         $_ .= "goto $lab;}";
  533.         }
  534.         $tseen++;
  535.         next;
  536.     if (/^y/) {
  537.         s/abcdefghijklmnopqrstuvwxyz/a-z/g;
  538.         s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
  539.         s/abcdef/a-f/g;
  540.         s/ABCDEF/A-F/g;
  541.         s/0123456789/0-9/g;
  542.         s/01234567/0-7/g;
  543.         $_ .= ';';
  544.     if (/^=/) {
  545.         $_ = 'print $.;';
  546.         next;
  547.     if (/^q/) {
  548.         chop($_ = &q(<<'EOT'));
  549. :    close(ARGV);
  550. :    @ARGV = ();
  551. :    next LINE;
  552.         $sawnext++;
  553.         next;
  554.     } continue {
  555.     if ($space) {
  556.         s/^/$space/;
  557.         s/(\n)(.)/$1$space$2/g;
  558.     last;
  559.     }
  560.     $_;
  561. sub fetchpat {
  562.     local($outer) = @_;
  563.     local($addr) = $outer;
  564.     local($inbracket);
  565.     local($prefix,$delim,$ch);
  566.     # Process pattern one potential delimiter at a time.
  567.     DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
  568.     $prefix = $1;
  569.     $delim = $2;
  570.     if ($delim eq '\\') {
  571.         s/(.)//;
  572.         $ch = $1;
  573.         $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
  574.         $ch = 'b' if $ch =~ /^[<>]$/;
  575.         $delim .= $ch;
  576.     elsif ($delim eq '[') {
  577.         $inbracket = 1;
  578.         s/^\^// && ($delim .= '^');
  579.         s/^]// && ($delim .= ']');
  580.     elsif ($delim eq ']') {
  581.         $inbracket = 0;
  582.     elsif ($inbracket || $delim ne $outer) {
  583.         $delim = '\\' . $delim;
  584.     $addr .= $prefix;
  585.     $addr .= $delim;
  586.     if ($delim eq $outer && !$inbracket) {
  587.         last DELIM;
  588.     }
  589.     $addr =~ s/\t/\\t/g;
  590.     &simplify($addr);
  591.     $addr;
  592. sub q {
  593.     local($string) = @_;
  594.     local($*) = 1;
  595.     $string =~ s/^:\t?//g;
  596.     $string;
  597. sub simplify {
  598.     $_[0] =~ s/_a-za-z0-9/\\w/ig;
  599.     $_[0] =~ s/a-z_a-z0-9/\\w/ig;
  600.     $_[0] =~ s/a-za-z_0-9/\\w/ig;
  601.     $_[0] =~ s/a-za-z0-9_/\\w/ig;
  602.     $_[0] =~ s/_0-9a-za-z/\\w/ig;
  603.     $_[0] =~ s/0-9_a-za-z/\\w/ig;
  604.     $_[0] =~ s/0-9a-z_a-z/\\w/ig;
  605.     $_[0] =~ s/0-9a-za-z_/\\w/ig;
  606.     $_[0] =~ s/\[\\w\]/\\w/g;
  607.     $_[0] =~ s/\[^\\w\]/\\W/g;
  608.     $_[0] =~ s/\[0-9\]/\\d/g;
  609.     $_[0] =~ s/\[^0-9\]/\\D/g;
  610.     $_[0] =~ s/\\d\\d\*/\\d+/g;
  611.     $_[0] =~ s/\\D\\D\*/\\D+/g;
  612.     $_[0] =~ s/\\w\\w\*/\\w+/g;
  613.     $_[0] =~ s/\\t\\t\*/\\t+/g;
  614.     $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
  615.     $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
  616. !NO!SUBS!
  617. chmod 755 s2p
  618. $eunicefix s2p
  619.